home *** CD-ROM | disk | FTP | other *** search
/ Programmer Power Tools / Programmer Power Tools.iso / aijournl / ai_oct86.arc / INSIDE2.LTG < prev    next >
Encoding:
Text File  |  1986-07-16  |  3.6 KB  |  109 lines
  1.  
  2. LISTING 2 
  3.  
  4. ;;; Production System.  Copyright Raul E. Valdes-Perez, 1986.  All Rights Reserved.
  5. ;;; property list of rule:
  6. ;;;   patterns, assert, delete, good-all-bindings, best-bindings
  7. ;;; property list of fact:
  8. ;;; datum, origin
  9.  
  10. (defun run ()
  11.   (prog (eligible-rules rule-to-fire)
  12.     loop
  13.     (pr "matching rules")
  14.     (mapcar '(lambda (rule) 
  15.            (putprop rule 
  16.                 (remove-useless-bindings rule (match-rule rule))
  17.                 'good-all-bindings)) *rules*)
  18.     (setq eligible-rules (collect-eligible-rules *rules*))
  19.     (cond ((null eligible-rules) (return nil)))
  20.     (setq rule-to-fire (resolve-conflict eligible-rules))
  21.     (pr "firing the rule ...") (see-rule rule-to-fire)
  22.     (execute-rule rule-to-fire)
  23.     (go loop)))
  24.  
  25. ;;; returns rules that are eligible for firing
  26. (defun collect-eligible-rules (rules)
  27.   (cond ((null rules) nil)
  28.     ((get (car rules) 'good-all-bindings)
  29.      (cons (car rules) (collect-eligible-rules (cdr rules))))
  30.     (t (collect-eligible-rules (cdr rules)))))
  31.  
  32. ;;; filters out useless bindings
  33. (defun remove-useless-bindings (rule all-bindings)
  34.   (cond ((null all-bindings) nil)
  35.     ;could also check for deleting facts which are not present
  36.     ((asserts-only-duplicates? (get rule 'assert) (car all-bindings))
  37.      (remove-useless-bindings rule (cdr all-bindings)))
  38.     (t (cons (car all-bindings) 
  39.          (remove-useless-bindings rule (cdr all-bindings))))))
  40.  
  41. (defun asserts-only-duplicates? (assertions bindings)
  42.   (not (member 'nil
  43.            (mapcar 'datum-present? (bind-assertions assertions bindings)))))
  44.  
  45. (defun execute-rule (rule)
  46.   (setq *facts* 
  47.     (delete-data
  48.      (bind-assertions (get rule 'delete) (get rule 'best-bindings))
  49.      *facts*))
  50.   (mapcar
  51.    '(lambda (new-datum)
  52.       (print "adding fact: ") (pr new-datum)
  53.       (add-fact new-datum rule))
  54.    (bind-assertions (get rule 'assert) (get rule 'best-bindings))))
  55.  
  56. รจ(defun delete-data (data facts)
  57.   (cond ((null facts) nil)
  58.     ((member 
  59.        't (mapcar 
  60.         '(lambda (datum) (equal datum (get (car facts) 'datum)))
  61.         data))
  62.      (print "deleting fact: ") (pr (get (car facts) 'datum))
  63.      (delete-data data (cdr facts)))
  64.     (t (cons (car facts) (delete-data data (cdr facts))))))
  65.                 
  66. ;;; returns the single rule and sets best-bindings on the property list
  67. (defun resolve-conflict (rules)
  68.   (prog (rule)
  69.     (setq rule (most-specific (car rules) (cdr rules)))
  70.     (putprop rule (car (get rule 'good-all-bindings)) 'best-bindings)
  71.     (return rule)))
  72.  
  73. (defun most-specific (best rest)
  74.   (cond ((null rest) best)
  75.     ((> (length (get best 'patterns)) (length (get (car rest) 'patterns)))
  76.      (most-specific best (cdr rest)))
  77.     (t (most-specific (car rest) (cdr rest)))))
  78.   
  79. (defun see-rule (rule)
  80.   (pr "LHS")
  81.   (mapcar 'pr (get rule 'patterns))
  82.   (pr "RHS")
  83.   (mapcar 'pr (get rule 'assert))
  84.   (pr "with bindings")
  85.   (pr (get rule 'best-bindings)))
  86.  
  87. (defun pr (obj)
  88.   (print obj) (terpri))
  89.  
  90. (defun datum-present? (datum)
  91.   (datum-present2? datum *facts*))
  92.  
  93. (defun datum-present2? (datum facts)
  94.   (cond ((null facts) nil)
  95.     ((equal datum (get (car facts) 'datum)))
  96.     (t (datum-present2? datum (cdr facts)))))
  97.  
  98. (defun bind-assertions (assertions bindings)
  99.   (mapcar '(lambda (assertion)
  100.          (bind-assertion assertion (car bindings))) assertions))
  101.  
  102. (defun bind-assertion (assertion pairs)
  103.   (cond ((null assertion) nil)
  104.     ((use? (car assertion)) 
  105.      (cons (cdr (assoc (cadar assertion) pairs))
  106.            (bind-assertion (cdr assertion) pairs)))
  107.     (t (cons (car assertion) (bind-assertion (cdr assertion) pairs)))))
  108.  
  109. (defun use? (u-item)
  110.   (and (listp u-item) (eq (car u-item) '*use*)))